home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / dragNdrop.tcl.z / dragNdrop.tcl
Text File  |  2002-07-08  |  4KB  |  191 lines
  1. #
  2. # $Id: dragNdrop.tcl,v 1.2 1999/03/26 18:02:55 cwg Exp $
  3. #
  4. # Exmh drag&drop by John Robert LoVerso <john@loverso.southborough.ma.us>
  5. # Selection export by Fred Douglis <douglis@research.att.com>
  6. #
  7.  
  8. if {[info procs tlog-add] == ""} {proc tlog-add args {}}
  9.  
  10.  
  11. set dragdrop(dragging) 0
  12.  
  13. #
  14. # Attach routines
  15. #
  16.  
  17. proc Drag_Attach {w selectfunc mod b} {
  18.     if {$mod != ""} {append mod -}
  19.     bind $w <$mod$b>        [list $selectfunc %W %X %Y %x %y]
  20.     bind $w <${mod}B$b-Motion>    {DragMotion %X %Y}
  21.     bind $w <Any-ButtonRelease-$b>    {Drop %X %Y}
  22. }
  23. proc Drop_Attach {w dropfunc} {
  24.     global dragdrop
  25.     set dragdrop($w,drop) $dropfunc
  26.     lappend dragdrop(drops) $w
  27. }
  28.  
  29. #
  30. # Drag Source Initiation
  31. #
  32.  
  33. #    set dragvar(source)    <source widget>
  34. #    set dragvar(decorate)    <dragDecorationFunction>
  35. #    set dragvar(callback)    <dropCallbackFunction>
  36. #
  37. # Data description:
  38. #    set dragvar(types) {folder filename}
  39. #        List of data types
  40. #    set dragvar(data,folder) $folder
  41. #    set dragvar(data,filename) $mhProfile(path)/$folder
  42. #        One data variable for each type
  43. #    set dragvar(formats) string
  44. #    set dragvar(format,folder) string
  45. #    set dragvar(format,filename) string
  46. #        List of supported formats, one format per type
  47. #    set dragvar(type,string) folder
  48. #        Default or most appropriate type for given format
  49. #
  50. #    Drag_Source dragvar $x $y
  51. #
  52. # dragvar is linked to global dragging.  During drag, these are valid:
  53. #    dragdrop(text)    text representation of data
  54.  
  55. proc Drag_Source {dragvar x y} {
  56.     global dragdrop
  57.  
  58.     uplevel #0 "upvar #0 $dragvar dragging"
  59.     global dragging
  60.  
  61.     #
  62.     set dragdrop(text) $dragging(data,$dragging(type,string))
  63.     set dragdrop(dragging) 1
  64.  
  65. tlog-add .t Drag_Start $dragdrop(text)
  66.  
  67.     set w [set dragdrop(w) .drag]
  68.     if ![winfo exists $w] {
  69.         toplevel $w -cursor hand2
  70.             wm group $w .
  71.         wm transient $w .
  72.         wm override $w 1
  73.         wm withdraw $w
  74.         update idletasks
  75.     }
  76.  
  77.     set slaves [pack slaves $w]
  78.     if {$slaves != {}} {
  79.         eval pack forget $slaves
  80.     }
  81.     if [info exists dragging(decorate)] {
  82.         $dragging(decorate) $w
  83.     } else {
  84.         DragDecorateSimple $w
  85.     }
  86.  
  87.     # Allow geom to be updated
  88.     update idletasks
  89.     set dragdrop(yadj) [expr [winfo height $w] * 3 / 4]
  90.     set dragdrop(xadj) [expr [winfo width $w] / 2]
  91.  
  92.     DragMotion $x $y
  93.     wm deiconify $w
  94.     wm override $w 1
  95.     raise $w
  96.  
  97.     Drag_ExportString $dragdrop(text)
  98. }
  99.  
  100. proc DragDecorateSimple {f} {
  101.     global dragdrop
  102.  
  103.     set l $f.label
  104.     if ![winfo exists $l] {
  105.         label $l
  106.     }
  107.     pack $l
  108.     $l config -text $dragdrop(text)
  109. }
  110.  
  111. proc DragMotion {x y} {
  112.     global dragdrop
  113.  
  114.     if !$dragdrop(dragging) return
  115.     wm geom $dragdrop(w) \
  116.         +[expr $x - $dragdrop(xadj)]+[expr $y - $dragdrop(yadj)]
  117. }
  118.  
  119. proc Drop {x y} {
  120.     global dragdrop
  121.  
  122.     if !$dragdrop(dragging) return
  123.     set dragdrop(dragging) 0
  124.  
  125.     wm withdraw $dragdrop(w)
  126.     set dropw [winfo containing $x $y]
  127.     set func {}
  128.     set w {}
  129.     if {$dropw != {}} {
  130.         foreach w [list $dropw [winfo toplevel $dropw]] {
  131.             if [info exists dragdrop($w,drop)] {
  132.                 set func $dragdrop($w,drop)
  133.                 break;
  134.             }
  135.         }
  136.         if {$func == {}} {
  137.             foreach w $dragdrop(drops) {
  138.                 if [string match ${w}* $dropw] {
  139.                     set func $dragdrop($w,drop)
  140.                     break;
  141.                 }
  142.             }
  143.         }
  144.     }
  145.  
  146. tlog-add .t Drop $dragdrop(text) on $x,$y --> $dropw ($func $w)
  147.  
  148.     if {$func != {}} {
  149.         if [catch {$func $dropw $x $y} err] {
  150.             tlog-add .t drop error $err
  151.         }
  152.     }
  153.  
  154.     global dragging
  155.     if [info exists dragging(callback)] {
  156.         if [catch {$dragging(callback) $dropw $x $y} err] {
  157.             tlog-add .t callback error $err
  158.         }
  159.     }
  160. }
  161.  
  162. #
  163. # Interface to export selection
  164. #
  165.  
  166. proc Drag_ExportString {s} {
  167.     global dragdrop
  168.  
  169.     set dragdrop(exported) $s
  170.     selection own $dragdrop(w) DragExportNothing
  171.     selection handle $dragdrop(w) DragExportName
  172.     Exmh_Status "$s is current selection"
  173. }
  174.  
  175. proc DragExportName {offset maxBytes} {
  176.     global dragdrop
  177.     if [catch {set dragdrop(exported)} s] {
  178.     return ""
  179.     }
  180.     return $s
  181. }
  182.  
  183. proc DragExportNothing {} {
  184.     global dragdrop
  185.     if [catch {set dragdrop(exported)} s] return
  186.     if [string match "$s is current selection" [Exmh_OldStatus]] {
  187.     Exmh_Status ""
  188.     }
  189.     unset dragdrop(exported)
  190. }
  191.